home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 050 / madtrb17.arc / TDIR.PAS < prev    next >
Pascal/Delphi Source File  |  1985-10-06  |  17KB  |  532 lines
  1. PROGRAM Volume;
  2.  
  3. TYPE
  4.   Str11 = String[11];
  5.   Str255 = String[255];
  6.   Reg = Record case Integer of
  7.           1: (AX,BX,CX,DX,BP,SI,DI,DS,ES,Flags : Integer);
  8.           2: (AL,AH,BL,BH,CL,CH,DL,DH          : Byte);
  9.         End;
  10.   XFCB = Record                      { Extended File Control Block }
  11.         Flag : Byte;                 { Set to $FF to Identify as Extended FCB }
  12.         FRes : Array[1..5] of Byte;  { 5 Reserved Bytes }
  13.         Att  : Byte;                 { Attribute of File }
  14.         Drive : Byte;                { 0 = Default, 1 = A, 2 = B }
  15.         FName : Array[1..8] of Char; { File Name }
  16.         Ext   : Array[1..3] of Char; { Extension }
  17.         CBlock : Integer;            { Current Block Number }
  18.         RSize  : Integer;            { Logical Record Size }
  19.         FSize  : Integer;            { File Size }
  20.         Date   : Integer;            { Date Created/Updated }
  21.         SRes   : Array[1..10] of Byte;  { 10 Reserved Bytes }
  22.         RNum   : Byte;                  { Cur. Rel. Record Number in Block }
  23.         RRNum  : Array[1..4] of Byte;   { Rel. Rec. Rel. to Begining of File }
  24.       End;
  25.  
  26.   DTARec = Record
  27.         XStuff    : Array[1..7] of Byte;  { 1st 7 bytes of Ext. FCB }
  28.         DDrive    : Byte;                 { Drive Number }
  29.         FileName  : Array[1..8] of Char;  { File Name }
  30.         Extension : Array[1..3] of Char;  { Extension }
  31.         Attribute : Byte;                 { Attribute }
  32.         Reserved  : Array[1..10] of Byte; { 10 Reserved Bytes }
  33.         FileTime  : Integer;              { Time Created/Updated }
  34.         FileDate  : Integer;              { Date Created/Updated }
  35.         Cluster   : Integer;              { Starting Cluster Number }
  36.         FileSize  : Array[1..4] of Byte;  { File Size in Bytes }
  37.       End;
  38.  
  39.   MFCB = Array[0..43] of char;  { Modified XFCB Used to Rename Files }
  40.  
  41.   E = Record
  42.     EName : String[8];
  43.     EExt  : String[4];
  44.   End;
  45.  
  46. VAR
  47.   FCB             : XFCB;
  48.   DTA             : DTARec;
  49.   ModFCB          : MFCB;
  50.   Regs            : Reg;
  51.   OldVolumeName,
  52.   NewVolumeName   : String[11];
  53.   OldVolumeNameDate : String[20];
  54.   Drive             : Char;
  55.   Directory         : String[80];
  56.   SpaceFree         : Real;
  57.   AnyStr            : String[255];
  58.   Day,Month,Year,
  59.   Hour,Minute,
  60.   ScreenCount     : Integer;
  61.   Size         : Real;
  62.   AP           : Char;
  63.   ID           : Boolean;
  64.   Entry        : Array[1..80] of E;
  65.   EntryNum     : Integer;
  66.  
  67. PROCEDURE Beep;
  68.   Begin
  69.     Sound(660);Delay(60);
  70.     Sound(440);Delay(60);
  71.     Sound(660);Delay(60);
  72.     Sound(440);Delay(60);
  73.     NoSound;
  74.   End; { procedure Beep }
  75.  
  76. PROCEDURE DrawBox(Top,Bottom,Left,Right : Integer);
  77.   VAR I:Integer;
  78.   Begin
  79.     LowVideo;
  80.     GotoXY(Left,Top); Write(#213);
  81.     For I := Left+1 to Right-1 do Write(#205);
  82.     Write(#184);
  83.     For I := Top+1 to Bottom-1 do begin
  84.       GotoXY(Left,I);Write(#179);
  85.       GotoXY(Right,I);Write(#179);
  86.     End;
  87.     GotoXY(Left,Bottom); Write(#212);
  88.     For I := Left+1 to Right-1 do Write(#205);
  89.     Write(#190);
  90.     NormVideo;
  91.   End; { procedure DrawBox }
  92.  
  93. PROCEDURE WriteHiLo(S:Str255);
  94.   VAR I : Integer;
  95.   Begin
  96.     For I := 1 to Length(S) do
  97.       If S[I] = '@' then LowVideo Else
  98.       If S[I] = '%' then NormVideo Else
  99.       Write(S[I]);
  100.     NormVideo;
  101.   End; { procedure WriteHiLow }
  102.  
  103. FUNCTION Freespace:real;
  104. var
  105.   fr  :   real;
  106. begin
  107.    with regs do
  108.    begin
  109.      dx := 0;
  110.      ah := $36;
  111.      MsDos(regs);
  112.      fr := bx;
  113.      if ax > 0 then Freespace := fr * ax * cx
  114.      else Freespace := 0
  115.    end;
  116. end;
  117.  
  118. PROCEDURE TimeDate;
  119.   Begin
  120.   With DTA do begin
  121.     Size := (FileSize[1] * 1.0) +
  122.             (FileSize[2] * 256.0) +
  123.             (FileSize[3] * 65536.0);
  124.     Year := (FileDate shr 9) + 80;
  125.     Month := (FileDate shl 7) shr 12;
  126.     Day := (FileDate shl 11) shr 11;
  127.     Hour := FileTime shr 11;
  128.     If Hour >= 12 then begin
  129.       AP := 'p';
  130.       Hour := Hour - 12;
  131.     End Else AP := 'a';
  132.     If Hour = 0 then Hour := 12;
  133.     Minute := (FileTime shl 5) shr 10;
  134.   End;
  135.   End; { procedure TimeDate }
  136.  
  137. PROCEDURE ShowEntry;
  138.   VAR
  139.     I            : Integer;
  140.     Str80        : String[80];
  141.  
  142.   PROCEDURE ShowHeader;
  143.     Begin
  144.       ClrScr;
  145.       NormVideo;
  146.       Write('Volume Name: ',OldVolumeName);
  147.       LowVideo;
  148.       WriteLn('  ',SpaceFree:7:0,' Bytes Free');
  149.       NormVideo;
  150.       If Length(OldVolumeNameDate) > 0 then begin
  151.         WriteLn('    Created: ',OldVolumeNameDate);
  152.         ScreenCount := ScreenCount + 1;
  153.       End;
  154.       WriteLn('  Directory: ',Drive,':',Directory);
  155.       WriteLn;
  156.       LowVideo;
  157.       WriteLn('File Name       Size      Date    Time');
  158.       WriteLn('--------------------------------------');
  159.       NormVideo;
  160.       ScreenCount := ScreenCount + 5;
  161.     End; { procedure ShowHeader }
  162.  
  163.   Begin
  164.   With DTA do begin
  165.     TimeDate;
  166.     If (FCB.Att = 8) and (Attribute = 8) then Exit;
  167.     If ScreenCount >= 22 then begin
  168.       LowVideo;
  169.       ScreenCount := 0;
  170.       WriteLn('--------------------------------------');
  171.       WriteLn('MORE... press any key to continue');
  172.       Repeat until KeyPressed;
  173.       NormVideo;
  174.     End;
  175.     If ScreenCount = 0 then ShowHeader;
  176.     ScreenCount := ScreenCount + 1;
  177.     Attribute := Attribute and 31;
  178.     If Attribute <> 0 then LowVideo;
  179.     If Attribute = 8 then Write(FileName,Extension,'         ')
  180.       Else If (Attribute and $10) = 16
  181.            then Write(FileName,Extension,'  <DIR>  ')
  182.       Else Write(FileName,' ',Extension,Size:8:0);
  183.     Write('  ',Month:2,'-');
  184.     If Day < 10 then Write('0');
  185.     Write(Day,'-',Year);
  186.     Write('  ',Hour:2,':');
  187.     If Minute < 10 then Write('0');
  188.     Write(Minute,ap);
  189.     If (Attribute and $01) = 1 then Write('  ReadOnly ');
  190.     If (Attribute and $02) = 2 then Write('  Hidden ');
  191.     If (Attribute and $04) = 4 then Write('  System ');
  192.     If (Attribute and $08) = 8 then Write('  <-- Volume Name!');
  193.     If (Attribute and $10) = 16 then Write('  SubDirectory');
  194.     If (Attribute and $20) = 32 then Write('  Archive');
  195.     NormVideo;
  196.     WriteLn;
  197.   End; { with DTA }
  198.   End; { procedure ShowEntry }
  199.  
  200. PROCEDURE SetDTA;
  201.   Begin
  202.     Regs.AX := $1A00;       { Func.Call $1A (Set DTA) }
  203.     Regs.DS := Seg(DTA);
  204.     Regs.DX := Ofs(DTA);
  205.     MsDos(Regs);
  206.   End;
  207.  
  208. PROCEDURE FindFirstEntry(SearchAttribute : Byte);
  209.   VAR I : Integer;
  210.   Begin
  211.   With FCB do begin
  212.     FillChar(FCB,SizeOf(FCB),0);
  213.     Flag := $FF;
  214.     Att := SearchAttribute;
  215.     For I := 1 to 8 do FName[I] := '?';
  216.     For I := 1 to 3 do Ext[I] := '?';
  217.     Regs.DS := Seg(FCB);
  218.     Regs.DX := Ofs(FCB);
  219.     Regs.AX := $1100;       { Func.Call $11 (Search for First Entry) }
  220.     MsDos(Regs);
  221.     If (Att = 8) and (DTA.Attribute = 8) and (Regs.AL <> $FF) then begin
  222.       TimeDate;
  223.       OldVolumeName := DTA.FileName + DTA.Extension;
  224.       Str(Month,AnyStr);
  225.       OldVolumeNameDate := AnyStr + '-';
  226.       If Day < 10 then OldVolumeNameDate := OldVolumeNameDate + '0';
  227.       Str(Day,AnyStr);
  228.       OldVolumeNameDate := OldVolumeNameDate + AnyStr + '-';
  229.       Str(Year,AnyStr);
  230.       OldVolumeNameDate := OldVolumeNameDate + AnyStr + '  ';
  231.       Str(Hour:2,AnyStr);
  232.       OldVolumeNameDate := OldVolumeNameDate + AnyStr + ':';
  233.       If Minute < 10 then OldVolumeNameDate := OldVolumeNameDate + '0';
  234.       Str(Minute,AnyStr);
  235.       OldVolumeNameDate := OldVolumeNameDate + AnyStr + AP;
  236.     End;
  237.   End; { with FCB }
  238.   End; { procedure FindFirstEntry }
  239.  
  240. PROCEDURE FindNextEntry;
  241.   Begin
  242.     Regs.DS := Seg(FCB);
  243.     Regs.DX := Ofs(FCB);
  244.     Regs.AX := $1200;    { Func.Call $12 (Search for Next Entry) }
  245.     MsDos(Regs);
  246.   End; { procedure FindNextEntry }
  247.  
  248. PROCEDURE FixName(VAR S:Str11);
  249.   VAR I : Integer;
  250.   Begin
  251.     For I := 1 to Length(S) do S[I] := UpCase(S[I]);
  252.     S := S + Copy('           ',1,11-Length(S));
  253.   End; { procedure FixName }
  254.  
  255. PROCEDURE ChangeVolumeName(Old,New:Str11);
  256.   VAR I : Integer;
  257.   Begin
  258.     FixName(Old);
  259.     FixName(New);
  260.     FillChar(ModFCB,SizeOf(ModFCB),#32);
  261.     ModFCB[0] := #255;
  262.     ModFCB[6] := #8;
  263.     ModFCB[7] := #0;
  264.     For I := 1 to 11 do ModFCB[I+7] := Old[I];
  265.     For I := 1 to 11 do ModFCB[I+23] := New[I];
  266.     Regs.DS := Seg(ModFCB);
  267.     Regs.DX := Ofs(ModFCB);
  268.     Regs.AX := $1700;
  269.     MsDos(Regs);
  270.   End; { procedure ChangeVolumeName }
  271.  
  272. PROCEDURE CreateVolumeName(S:Str11);
  273.   VAR I : Integer;
  274.   Begin
  275.   With FCB do begin
  276.     FillChar(FCB,SizeOf(FCB),0);
  277.     Flag := $FF;
  278.     Att := $08;
  279.     Drive := $00;
  280.     FixName(S);
  281.     For I := 1 to 8 do FName[I] := S[I];
  282.     For I := 9 to Length(S) do Ext[I-8] := S[I];
  283.     Regs.DS := Seg(FCB);
  284.     Regs.DX := Ofs(FCB);
  285.     Regs.AX := $1600;       { Func.Call $16 (Create File) }
  286.     MsDos(Regs);
  287.     WriteLn(Regs.AL,' Opening File');
  288.     Regs.DS := Seg(FCB);
  289.     Regs.DX := Ofs(FCB);
  290.     Regs.AX := $1000;       { Func.Call $10 (Close File) }
  291.     MsDos(Regs);
  292.     WriteLn(Regs.AL,' Closing File');
  293.   End; { with FCB }
  294.   End; { procedure CreateVolumeName }
  295.  
  296. PROCEDURE FindVolume;
  297.   VAR I : Integer;
  298.   Begin
  299.   With FCB do begin
  300.     FindFirstEntry(55);
  301.     If Regs.AL <> $FF then ShowEntry;
  302.     If Regs.AL <> $FF then begin
  303.       Repeat
  304.         FindNextEntry;
  305.         If Regs.AL <> $FF then ShowEntry;
  306.       Until Regs.AL = $FF;
  307.     End;
  308.     LowVideo;
  309.     WriteLn('--------------------------------------');
  310.     Write('Press any key to continue... ');
  311.     Repeat until KeyPressed;
  312.     NormVideo;
  313.   End; { with FCB }
  314.   End; { procedure FindVolume }
  315.  
  316. PROCEDURE DisplayID;
  317.   Begin
  318.     DrawBox(1,25,55,79);
  319.     GotoXY(57,2);Write('written by');
  320.     GotoXY(57,3);Write('---------------------');
  321.     GotoXY(57,4);Write('JAMESTOWN SOFTWARE');
  322.     GotoXY(57,5);Write('2508 Valley Forge Dr.');
  323.     GotoXY(57,6);Write('Madison, WI  53719');
  324.     GotoXY(57,7);Write('---------------------');
  325.     GotoXY(57,8);Write('on a modified');
  326.     GotoXY(57,9);Write('SHAREWARE BASIS');
  327.     GotoXY(57,11);Write('If you like and');
  328.     GotoXY(57,12);Write('use this program,');
  329.     GotoXY(57,13);Write('send me a letter and');
  330.     GotoXY(57,14);Write('let me know...');
  331.     GotoXY(57,16);Write('If you would like a');
  332.     GotoXY(57,17);Write('copy of the TURBO');
  333.     GotoXY(57,18);Write('Pascal source code,');
  334.     GotoXY(57,19);Write('send at least a');
  335.     GotoXY(57,20);Write('couple of quarters!');
  336.     GotoXY(57,21);Write('---------------------');
  337.     GotoXY(57,22);Write('(Who said you can','''','t');
  338.     GotoXY(57,23);Write(' get rich writing');
  339.     GotoXY(57,24);Write(' software?!?)');
  340.   End; { procedure DisplayID }
  341.  
  342. PROCEDURE SelectEntry(VAR Choice:Integer);
  343.   VAR Ch:Char;
  344.       X,Y,OldChoice : Integer;
  345.   Begin
  346.     OldChoice:=Choice;
  347.     Repeat
  348.       X:=1+(((OldChoice-1) mod 4)*14);
  349.       Y:=7+((OldChoice-1) div 4);
  350.       GotoXY(X,Y);
  351.       Write(Entry[OldChoice].EName,Entry[OldChoice].EExt);
  352.       Textcolor(Black);
  353.       TextBackground(LightGray);
  354.       X:=1+(((Choice-1) mod 4)*14);
  355.       Y:=7+((Choice-1) div 4);
  356.       GotoXY(X,Y);
  357.       Write(Entry[Choice].EName,Entry[Choice].EExt);
  358.       GotoXY(1,8+(EntryNum div 5));
  359.       NormVideo;
  360.       OldChoice:=Choice;
  361.       Repeat
  362.         Read(Kbd,Ch);
  363.         If Ch = #27 then begin
  364.           Read(Kbd,Ch);
  365.           If NOT (Ch in [#71,#72,#75,#77,#79,#80]) then Beep;
  366.         End;
  367.       Until Ch in [#27,#71,#72,#75,#77,#79,#80,#13];
  368.       If Ch=#71 then Choice:=1;
  369.       If Ch=#72 then Choice:=Choice-4;
  370.       If Ch=#77 then Choice:=Choice+1;
  371.       If Ch=#75 then Choice:=Choice-1;
  372.       If Ch=#79 then Choice:=EntryNum;
  373.       If Ch=#80 then Choice:=Choice+4;
  374.       If Choice > EntryNum then Choice:=1;
  375.       If Choice < 1 then Choice:=EntryNum;
  376.     Until Ch in [#13,#27];
  377.     If Ch=#27 then Choice := 999;
  378.   End; { procedure SelectEntry }
  379.  
  380. PROCEDURE Menu;
  381.   VAR
  382.     MenuChoice,Ch : Char;
  383.     I : Integer;
  384.     S,S1 : Str255;
  385.   Begin
  386.   Repeat
  387.     ClrScr;
  388.     If ID then DisplayID;
  389.     GotoXY(1,1);
  390.     GetDir(0,Directory);
  391.     SetDTA;
  392.     FindFirstEntry(8);
  393.     If Regs.AL = $FF then begin
  394.       OldVolumeName := '<NONE>';
  395.       OldVolumeNameDate := '';
  396.     End;
  397.     For I := 1 to Length(Directory) do Directory[I] := UpCase(Directory[I]);
  398.     Drive := Directory[1];
  399.     Directory := Copy(Directory,3,length(Directory));
  400.     S:='@    Drive: %'+Drive;
  401.     WriteHiLo(S); WriteLn;
  402.     S:='@Directory: %'+Directory;
  403.     WriteHiLo(S); WriteLn;
  404.     S:='@   Volume: %'+OldVolumeName;
  405.     WriteHiLo(S); WriteLn;
  406.     Write('------------------------------------------------');
  407.     GotoXY(1,5);
  408.     LowVideo;
  409.     WriteLn('SUBDIRECTORIES on Selected Drive/Directory: ');
  410.     WriteLn;
  411.     NormVideo;
  412.     EntryNum := 0;
  413.     I:=0;
  414.     With FCB do begin
  415.       FindFirstEntry(16);
  416.       If (Regs.AL <> $FF) and ((DTA.Attribute and $10) = 16) then begin
  417.         I:=1;
  418.         Write(DTA.FileName,DTA.Extension);
  419.         LowVideo;
  420.         Write(' | ');
  421.         NormVideo;
  422.         EntryNum := EntryNum + 1;
  423.         Entry[EntryNum].EName := DTA.FileName;
  424.         Entry[EntryNum].EExt := DTA.Extension;
  425.       End;
  426.       If Regs.AL <> $FF then begin
  427.         Repeat
  428.           FindNextEntry;
  429.           If (Regs.AL <> $FF) and ((DTA.Attribute and $10) = 16) then begin
  430.             Write(DTA.FileName,DTA.Extension);
  431.             LowVideo;
  432.             Write(' | ');
  433.             NormVideo;
  434.             EntryNum := EntryNum + 1;
  435.             Entry[EntryNum].EName := DTA.FileName;
  436.             Entry[EntryNum].EExt := DTA.Extension;
  437.             I:=I+1;
  438.             If I >= 4 then begin
  439.               WriteLn;
  440.               I := 0
  441.             End;
  442.           End;
  443.         Until Regs.AL = $FF;
  444.       End;
  445.     End; { with FCB }
  446.     GotoXY(1,17);
  447.     WriteHiLo('@Select %A@ctive Drive');
  448.     WriteHiLo('   --    @Select %D@irectory'); WriteLn;
  449.     WriteHiLo('@Change or Create %V@olume Name (A: or B: only)'); WriteLn; WriteLn;
  450.     WriteHiLo('%S@how Disk Directory   ');
  451.     If ID = False then WriteHiLo('@Show Author %I@dentification');
  452.     WriteLn; WriteLn;
  453.     WriteHiLo('%Q@uit and return to DOS in selected subdirectory'); WriteLn; WriteLn;
  454.     Write('>');
  455.     Repeat
  456.       Read(Kbd,MenuChoice);
  457.       MenuChoice := Upcase(MenuChoice);
  458.       If NOT (MenuChoice in ['D','A','V','S','Q','I']) then Beep;
  459.     Until MenuChoice in ['D','A','V','S','Q','I'];
  460.     Write(MenuChoice);
  461.     If ID = True then begin
  462.       ID := False;
  463.       Window(55,1,79,25);ClrScr;
  464.       Window(1,1,80,25)
  465.     End;
  466.     Case MenuChoice of
  467.       'A' : Begin
  468.               S := '';
  469.               GotoXY(12,1); ClrEol;
  470.               ReadLn(S);
  471.               S := S[1] + ':';
  472.               {$I-}
  473.               ChDir(S);
  474.               {$I+}
  475.               If IOResult <> 0 then Beep;
  476.             End;
  477.       'D' : If EntryNum > 0 then begin
  478.               Window(1,16,79,25);ClrScr;
  479.               Window(1,1,80,25);
  480.               GotoXY(1,23);
  481.               WriteLn('Select with cursor keys, then press return. (Press Esc to abort)');
  482.               WriteHiLo('@Double dot (..) moves up one subdirectory...');
  483.               I:=1;
  484.               SelectEntry(I);
  485.               If I<>999 then begin
  486.                 S1:=Entry[I].EName;
  487.                 S:='';
  488.                 For I:=1 to Length(S1) do If S1[I]<>' ' then S:=S+S1[I];
  489.                 {$I-}
  490.                 ChDir(S);
  491.                 {$I+}
  492.                 If IOResult <> 0 then Beep;
  493.               End;
  494.             End;
  495.       'V' : Begin
  496.               If Drive in ['A'..'B'] then begin
  497.                 NewVolumeName := ' ';
  498.                 GotoXY(12,3); ClrEol;
  499.                 Read(NewVolumeName);
  500.                 FixName(NewVolumeName);
  501.                 GotoXY(1,6);
  502.                 If OldVolumeName = '<NONE>'
  503.                   then Write('Create NEW Volume Name: ',NewVolumeName)
  504.                   Else Write('Change ',OldVolumeName,' to ',NewVolumeName,'?');
  505.                 Write('  Y/N ');
  506.                 Repeat
  507.                   Read(Kbd,Ch);
  508.                   Ch := UpCase(Ch);
  509.                   If NOT (Ch in ['Y','N']) then Beep;
  510.                 Until Ch in ['Y','N'];
  511.                 If Ch = 'Y' then
  512.                   If OldVolumeName = '<NONE>'
  513.                     then CreateVolumeName(NewVolumeName)
  514.                     Else ChangeVolumeName(OldVolumeName,NewVolumeName);
  515.               End;
  516.             End;
  517.       'S' : Begin
  518.               SpaceFree := FreeSpace;
  519.               ClrScr;
  520.               ScreenCount := 0;
  521.               FindVolume;
  522.             End;
  523.       'I' : ID := True;
  524.     End;
  525.   Until MenuChoice = 'Q';
  526.   End; { procedure Menu }
  527.  
  528. Begin
  529.   ID := True;
  530.   Menu;
  531.   ClrScr;
  532. End.I